with ada.Unchecked_Deallocation;

with ada.Strings.fixed;
use ada.Strings;
use ada.Strings.fixed;

package body ariane.numerics.biginteger is

  subtype cmpres_t is integer range -1..1;
  subtype sign_t is integer range -1..1;

  -- underlying deallocation method
  -- note: seems it has to be declared after the object definition and
  --       invoked by a public wrapper method, as the deallocation method
  --       needs information of the object type
  procedure deallocate is new ada.Unchecked_Deallocation(Object=>object,
                                                         Name=>objectptr);

  -- get the maximum of two instances of length_t type
  function max(a, b : length_t) return length_t is
  begin
    if a > b then
      return a;
    else
      return b;
    end if;
  end max;

  -- get the minimum of two instances of length_t type
  function min(a, b : length_t) return length_t is
  begin
    if a > b then
      return b;
    else
      return a;
    end if;
  end min;

  -- compacts a given number so that its effective length is the same as
  -- the same as its array length
  function compact(o : object) return object is
    res : object(o.actln);
  begin
    for i in 1 .. o.actln loop
      res.cells(i) := o.cells(i);
    end loop;
    res.actln := o.actln;
    return res;
  end;

  -- returns the sign of the given value
  function getsgn(o : object) return sign_t is
  begin
    if o.cells(o.actln) > 0 then
      return 1;
    elsif o.cells(o.actln) < 0 then
      return -1;
    else
      return 0;
    end if;
  end getsgn;

  -- returns the absolute value of the big integer object
  function getabs(o : object) return object is
    res : object := o;
  begin
    if res.cells(res.actln) < 0 then
      res.cells(res.actln) := -res.cells(res.actln);
    end if;
    return res;
  end getabs;

  -- compares the absolute values of the two operands of length_t type
  -- ensure the two numbers are non-negative
  function cmpasabs(lhs, rhs : object) return cmpres_t is
  begin
    if lhs.actln < rhs.actln then
      return -1;
    elsif lhs.actln > rhs.actln then
      return 1;
    end if;

    for i in reverse 1 .. lhs.actln loop
      if lhs.cells(i) < rhs.cells(i) then
        return -1;
      elsif lhs.cells(i) > rhs.cells(i) then
        return 1;
      end if;
    end loop;

    return 0;

  end cmpasabs;

  -- adds two numbers; ensure the two numbers are non-negative
  -- the return value is neither made definite nor compacted
  procedure addasabs(lhs, rhs : object; res : out object) is
    maxn : length_t := max(lhs.actln, rhs.actln);
    minn : length_t := min(lhs.actln, rhs.actln);
    tmp : integer;
    carry : integer := 0;

    procedure handlehighdigits(highref : cells_t) is begin
      for i in minn + 1 .. maxn loop
        tmp := highref(i) + carry;
        if tmp > maxcellval then
          tmp := tmp - maxmulten;
          carry := 1;
        end if;
        res.cells(i) := tmp;
      end loop;

      if carry > 0 then
        res.cells(maxn + 1) := carry;
        res.actln := maxn + 1;
      else
        res.actln := maxn;
      end if;
    end handlehighdigits;

  begin
    for i in 1 .. minn loop
      tmp := lhs.cells(i) + rhs.cells(i) + carry;
      if tmp > maxcellval then
        tmp := tmp - maxmulten;
        carry := 1;
      else
        carry := 0;
      end if;
      res.cells(i) := tmp;
    end loop;

    if lhs.actln > rhs.actln then
      handlehighdigits(lhs.cells);
    else
      handlehighdigits(rhs.cells);
    end if;

  end addasabs;

  -- subtracts rhs from lhs; ensure that lhs is greater than rhs
  -- ensure the two numbers are non-negative
  -- the return value is neither made definite nor compacted
  procedure subasabs(lhs, rhs : object; res : out object) is
    tmp : integer;
    carry : integer := 0;
  begin
    for i in 1 .. rhs.actln loop
      tmp := lhs.cells(i) - rhs.cells(i) - carry;
      if tmp < 0 then
        tmp := tmp + maxmulten;
        carry := 1;
      end if;
      res.cells(i) := tmp;
      if tmp /= 0 then
        res.actln := i;
      end if;
    end loop;

    for i in rhs.actln + 1 .. lhs.actln loop
      tmp := lhs.cells(i) - carry;
      if tmp < 0 then
        tmp := tmp + maxmulten;
        carry := 1;
      end if;
      res.cells(i) := tmp;
      if tmp /= 0 then
        res.actln := i;
      end if;
    end loop;
  end subasabs;

  -- create a big integer object
  function create(cells : in cells_t) return object is
    n : length_t := cells'Length;
    actln : length_t := 1;
  begin
    for i in reverse 1 .. n loop
      if cells(i) /= 0 then
        actln := i;
        exit;
      end if;
    end loop;
    declare
      res : object(actln);
    begin
      for i in 1 .. actln loop
        res.cells(i) := cells(i);
      end loop;
      res.actln := actln;
      return res;
    end;
  end create;

  -- creates a big integer object on heap with value given by the argument
  function create(o : object) return objectptr is
    res : objectptr := new object(o.actln);
  begin
    for i in 1 .. o.actln loop
      res.cells(i) := o.cells(i);
    end loop;
    res.actln := o.actln;
    return res;
  end;

  -- gets the string representation of the big integer object
  function tostring(o : in object) return string is
    res : string := (integer(o.actln) * maxdigitspercell+1) * ' ';
    wr : positive := 1;
  begin
    for i in reverse 1 .. o.actln loop
      declare
        tmp : string := integer'Image(o.cells(i));
        trimmed : string := trim(tmp, both);
      begin
        if i = o.actln or else trimmed'length = 9 then
          overwrite(res, wr, trimmed);
          wr := wr + trimmed'Length;
        else
          declare
            pad : string := 9 * '0';
          begin
            overwrite(pad, 9 - trimmed'length, trimmed);
            overwrite(res, wr, pad);
            wr := wr + 9;
          end;
        end if;
      end;
    end loop;

    return res;
  end tostring;

  -- destroys the big integer object created on heap
  procedure free(p : in out objectptr) is
  begin
    deallocate(p);
  end free;

  -- defines operator "+" on big integers
  function "+"(lhs, rhs : in object) return object is
    res : object(lhs.actln + rhs.actln + 1);
    cmp : integer;
    labs : object := getabs(lhs);
    rabs : object := getabs(rhs);
    lsgn : sign_t := getsgn(lhs);
    rsgn : sign_t := getsgn(rhs);
  begin
    if lsgn = rsgn or else lsgn = 0 or else rsgn = 0 then
      addasabs(labs, rabs, res);
      if lsgn < 0 or rsgn < 0 then
        res.cells(res.actln) := -res.cells(res.actln);
      end if;
    else
      cmp := cmpasabs(labs, rabs);
      if cmp < 0 then
        subasabs(rabs, labs, res);
        if rsgn < 0 then
          res.cells(res.actln) := -res.cells(res.actln);
        end if;
      elsif cmp > 0 then
        subasabs(labs, rabs, res);
        if lsgn < 0 then
          res.cells(res.actln) := -res.cells(res.actln);
        end if;
      else
        res.actln := 1;
        res.cells(1) := 0;
      end if;
    end if;

    declare
      compacted : object := compact(res);
    begin
      return compacted;
    end;

  end "+";

  -- defines operator "-" on big integers
  function "-"(lhs, rhs : in object) return object is
    res : object(lhs.actln + rhs.actln + 1);
    cmp : integer;
    labs : object := getabs(lhs);
    rabs : object := getabs(rhs);
    lsgn : sign_t := getsgn(lhs);
    rsgn : sign_t := getsgn(rhs);
  begin
    if lsgn /= rsgn and then lsgn /= 0 and then rsgn /= 0 then
      cmp := cmpasabs(labs, rabs);
      if cmp < 0 then
        subasabs(rabs, labs, res);
        if rsgn < 0 then
          res.cells(res.actln) := -res.cells(res.actln);
        end if;
      elsif cmp > 0 then
        subasabs(labs, rabs, res);
        if lsgn < 0 then
          res.cells(res.actln) := -res.cells(res.actln);
        end if;
      else
        res.actln := 1;
        res.cells(1) := 0;
      end if;
    else
      addasabs(labs, rabs, res);
      if lsgn < 0 or rsgn < 0 then
        res.cells(res.actln) := -res.cells(res.actln);
      end if;
    end if;

    declare
      compacted : object := compact(res);
    begin
      return compacted;
    end;
  end "-";

end ariane.numerics.biginteger;

